BBS Toolkit/BBS Toolkit.iso/pc_board/reward12.zip/REWARD.PAS

Pascal/Delphi Source File | 1992-03-13 | 14KB | 532 lines

(*
 * Reward      - Generate a report of the top uploaders
 *               and Reward them with a special security level
 *               for PCBoard 14.x
 *
 * (C) 1989-1992 Samuel H. Smith, 17-sep-89 (rev. 29-Feb-92)
 *
 * This program is provided courtesy of:
 *         The Tool Shop
 *         Panorama City CA
 *         [phone]
 *
 *
 * Disclaimer
 * ----------
 *
 * I cannot be responsible for any damages resulting from the use or mis-
 * use of this program!
 *
 * If you have any questions, bugs, or suggestions, please contact me at
 * The Tool Shop,  [phone].
 *
 * Enjoy!     Samuel H. Smith
 *
 *)

{$DEFINE PCB14}

{$r-,s-}             (* enable range checking *)
{$v-}                (* allow variable length string params *)
{$M 50000,0,0}       {Stack, minheap, maxheap}


uses OpenShare,BufIO,Tools;

const
   version = 'v1.2';
   revdate = '03-13-92';
   pcb_version = '14.x';
   max_reward = 500;    {maximum number of users to reward}
   max_level = 100;     {maximum number of security level pairs in config}

type
   {yymmdd dates}
   yymmdd = char6;

   {level pair record}
   level_pair = record
      normal:  integer;
      bonus:   integer;
   end;

   {uploader information record}
   user_rec = record
      usernum:     word;
      name:        string[25];
      city:        string[25];
      date:        yymmdd;
      uploads:     word;
      level:       byte;
   end;

   {layout of the USERS file in PCBoard 14.x}
   pcb_user_rec = record
    {1  }name:          char25;
    {26 }city:          char24;
    {50 }passwd:        char12;         {no spaces allowed}
    {62 }busphone:      char13;
    {75 }phone:         char13;
    {88 }date:          yymmdd;         {yymmdd of last call}
    {94 }time:          char5;          {hh:mm  of last call}
    {99 }expert:        char;           {pcboard expert status Y or N}
    {100}protocol:      char;           {X, C, Y, N}
    {101}space1:        char;           {space - reserved}
    {102}filedate:      yymmdd;         {yymmdd of last file directory}
    {108}level:         byte;           {security level}
    {109}total_calls:   integer;        {number of times on system}
    {111}pagelen:       byte;           {page length}
    {112}uploads:       integer;        {number of uploads}
    {114}downloads:     integer;        {number of downloads}
    {116}downbytes:     double;         {daily download bytes so far}
    {124}usercomment:   char30;         {user entered comment field}
    {154}sysopcomment:  char30;         {sysop maintained comment field}
    {184}lastused:      integer;        {minutes used so far today}
    {186}expdate:       yymmdd;         {yymmdd expiration date}
    {192}explevel:      byte;           {expired security level}
    {193}curconf:       byte;           {current conference number}
    {194}conferences:   bitmap;         {area registration 1-39 (5 bytes)}
    {199}expconf:       bitmap;         {expired conference registration}
    {204}scanconf:      bitmap;         {user configured scan conferences}
    {209}downtotal:     double;         {total bytes downloaded, all calls}
    {217}uptotal:       double;         {total bytes uploaded, all calls}
    {225}dead:          char;           {positive delete flag, Y or N}

    {226}lastread:      array[0..39] of single;
                                        {last message pointer, main+39 conf's}

    {386}reserved:      char5;          {reserved for future use}

(*
 * THE FOLLOWING USERS FILE BYTES ARE TAKEN OVER BY PRODOOR
 * FOR STORAGE OF PRODOOR-SPECIFIC DATA FOR A USER.  OTHER DOOR
 * PROGRAMS SHOULD TAKE CARE TO NOT CONFLICT WITH THESE BYTE
 * POSITIONS!
 *)
    {391}extrarec:      word;           {record number for extra user record}

    {393}flags:         byte;           {prodoor user flag bits}

    {394}mailconf:      byte;           {conference user has mail in}
    {395}scratchnum:    byte;           {scratch file number - incremented for
                                         each use of a scratch file}
    {396}dooruse:       byte;           {times in prodoor, up to 255}
    {397}earned_k:      word;           {prodoor; earned kbytes}


    {399}reserve3:      word;           {used by qmail??}
    {total size: 400}
   end;


(* ----------------------------------------------------------- *)

{config file variables}
var
   headerfn:   filenames;
   trailerfn:  filenames;
   bltfn:      filenames;
   logfn:      filenames;
   userfn:     filenames;
   num_reward: integer;
   level:      array[1..max_level] of level_pair;
   levels:     integer;

{report files}
var
   logfd:      text;
   bltfd:      text;

{working storage}
var
   reward:     array[1..max_reward] of user_rec;
   rewards:    integer;

   usr:        pcb_user_rec;
   usrlevel:   integer;


(* ----------------------------------------------------------- *)
procedure load_config;
var
   fd:   text;
   i:    integer;
begin
   if paramcount <> 1 then
   begin
      writeln('Usage:   reward CONFIG_FILE');
      writeln('Example: reward reward.cnf');
      halt;
   end;

   assignText(fd,paramstr(1));
   {$i-} reset(fd); {$i+}
   if ioresult <> 0 then
   begin
      writeln('Can''t open config file: ',paramstr(1));
      halt;
   end;

   readln(fd,headerfn);
   readln(fd,trailerfn);
   readln(fd,bltfn);
   readln(fd,logfn);
   readln(fd,userfn);
   readln(fd,num_reward);

   readln(fd,levels);
   for i := 1 to levels do
      readln(fd,level[i].normal,level[i].bonus);

   close(fd);
end;

(* ----------------------------------------------------------- *)
function yymmdd_date: string6;
begin
   yymmdd_date := system_yy+system_mm+system_dd;
end;


(* ----------------------------------------------------------- *)
function expired: boolean;
begin
   expired := (usr.expdate <> '000000') and (usr.expdate < yymmdd_date);
end;


(* ----------------------------------------------------------- *)
procedure getlevel;
begin
   if expired then
      usrlevel := usr.explevel
   else
      usrlevel := usr.level;
end;


(* ----------------------------------------------------------- *)
procedure setlevel(level: integer);
begin
   if expired then
      usr.explevel := level
   else
      usr.level := level;
   usrlevel := level;
end;


(* ----------------------------------------------------------- *)
function expand_date(date: yymmdd): string8;
   {convert yymmdd to mm-dd-yy}
const
   tmp:  string8 = '  -  -  ';
begin
   tmp[1] := date[3];
   tmp[2] := date[4];
   tmp[4] := date[5];
   tmp[5] := date[6];
   tmp[7] := date[1];
   tmp[8] := date[2];
   expand_date := tmp;
end;


(* ----------------------------------------------------------- *)
function level_included(lev: integer; var entry: integer): boolean;
var
   i:       integer;

begin
   for i := 1 to levels do
      if (level[i].normal = lev) or (level[i].bonus = lev) then
      begin
         level_included := true;
         entry := i;
         exit;
      end;

   level_included := false;
end;


(* ----------------------------------------------------------- *)
procedure determine_rewards;
var
   fd:      buffered_file;
   entry:   integer;
   cnt:     word;

   procedure insert_user;
   var
      rec:  user_rec;
      i:    integer;
      j:    integer;

   begin
      if usr.uploads = 0 then
         exit;

      rec.usernum := btell(fd);
      rec.name := usr.name;
      rec.city := usr.city;
      rec.uploads := usr.uploads;
      rec.date := usr.date;
      rec.level := usrlevel;

      i := rewards;
      while (i > 0) and (usr.uploads > reward[i].uploads) do
         dec(i);

      if rewards = num_reward then
      begin
         if i = rewards then
            exit;
         for j := rewards-1 downto i+1 do
            reward[j+1] := reward[j];
      end
      else
      begin
         for j := rewards downto i+1 do
            reward[j+1] := reward[j];
         inc(rewards);
      end;

      reward[i+1] := rec;
   end;

begin
   bopen(fd,userfn,50,sizeof(usr));
   if berr then
   begin
      writeln('Can''t open user file ',userfn);
      halt;
   end;

   writeln('Scanning ',userfn);
   cnt :=0;
   rewards := 0;

   while not berr do
   begin
      inc(cnt);
      if (cnt mod 64) = 0 then
         write(cnt:7,' users'^M);

      bread(fd,usr);
      getlevel;

      if level_included(usrlevel,entry) then
         insert_user;
   end;

   bclose(fd);

   writeln(cnt:7,' users scanned.');
   writeln;

   writeln(logfd,'   ',cnt,' user records scanned, ',rewards,' will be rewarded for uploads.');
end;


(* ----------------------------------------------------------- *)
procedure give_rewards;
var
   fd:      buffered_file;
   rec:     word;
   upd:     word;
   entry:   integer;
   changed: boolean;

   procedure report_change( var fd: text; why: string);
   begin
      write(fd,'   ',usr.name,' ',usr.uploads:4,' U/L   ',why,' ',usrlevel);
      if expired then
         write(fd,' (exp ',usr.level,' ',expand_date(usr.expdate),')');
      writeln(fd);
   end;

   procedure update_user;
   var
      i: integer;
   begin
      changed := false;

      for i := 1 to rewards do
         if reward[i].usernum = rec then
         begin
            if usrlevel = level[entry].normal then
            begin
               setlevel(level[entry].bonus);

               report_change(logfd,'upgraded to');
               report_change(output,'upgraded to');
               changed := true;
            end
            else

            begin
               {report_change(logfd,' remains at');}
               report_change(output,'remains at');
            end;

            exit;
         end;


      {not in reward list, downgrade if needed}
      if usrlevel = level[entry].bonus then
      begin
         setlevel(level[entry].normal);
         report_change(logfd,'returned to');
         report_change(output,'returned to');
         changed := true;
      end;
   end;

begin
   bopen(fd,userfn,50,sizeof(usr));
   if berr then
   begin
      writeln('Can''t reopen user file ',userfn);
      halt;
   end;

   writeln('Updating ',userfn);
   upd := 0;

   while not berr do
   begin
      bread(fd,usr);
      getlevel;

      rec := btell(fd);

      if level_included(usrlevel,entry) then
      begin
         update_user;

         if changed then
         begin
            bseek(fd,rec-1);
            bwrite(fd,usr);
            inc(upd);
         end;
      end;

      if (rec mod 64) = 0 then
         write(rec:7,' users, ',upd,' updated.'^M);
   end;

   bclose(fd);
   writeln(rec:7,' users, ',upd,' updated.'^M);
   writeln(logfd,'   ',upd,' user records updated.');
   writeln;
end;


(* ----------------------------------------------------------- *)
procedure append_text(var fd: text; fn: filenames);
var
   ifd:  text;
   line: string;
begin
   assignText(ifd,fn);
   {$i-} reset(ifd); {$i+}
   if ioresult <> 0 then
   begin
      writeln('Can''t access text file: ',fn);
      exit;
   end;

   while not eof(ifd) do
   begin
      readln(ifd,line);
      writeln(fd,line);
   end;

   close(ifd);
end;


(* ----------------------------------------------------------- *)
procedure generate_blt;
var
   i: integer;
begin
   writeln('Generating ',bltfn);
   assignText(bltfd,bltfn);
   rewrite(bltfd);
   append_text(bltfd,headerfn);

   writeln(bltfd);
   writeln(bltfd,'  User Name               Calling From             Last On   # of UL''s  Level');
   writeln(bltfd,'  _________               ____________             ________  _________  _____');
   writeln(bltfd);

   for i := 1 to rewards do
   with reward[i] do
      writeln(bltfd,'  ',
                  copy(name,1,23):23,' ',
                  copy(city,1,23):23,'  ',
                  expand_date(date):8,' ',
                  uploads:8,
                  level:8);

   append_text(bltfd,trailerfn);
   close(bltfd);
end;


(* ----------------------------------------------------------- *)
procedure open_reports;
begin
   assignText(logfd,logfn);
   append(logfd);
   writeln(logfd,system_date,' ',system_time,' Reward ',version,' Execution Log');
end;


(* ----------------------------------------------------------- *)
procedure close_reports;
begin
   writeln(logfd,system_date,' ',system_time,' Reward Run Ended');
   writeln(logfd,'---------------------------------------------------');
   close(logfd);
   writeln('Reward Run Ended.');
end;



(* ----------------------------------------------------------- *)
(*
 * main program
 *
 *)

begin
   writeln;
   writeln('Reward ',version,' of ',revdate,' for PCBoard ',pcb_version);
   writeln('Copyright 1992 Samuel H. Smith;  Courtesy of The Tool Shop, [phone]');
   writeln;

   load_config;         {load config file, build list of levels
                         reward/normal to work with}

   open_reports;

   determine_rewards;   {pass through user file and build list of users
                         in configured security levels, keeping only the
                         top uploaders in the list}

   give_rewards;        {pass through user file again, addigning top
                         uploaders to reward level and returning others
                         to the normal level}

   generate_blt;

   close_reports;
end.